(in-package :dhs-db-persist)

(declaim #.*compile-decl*)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (handler-case
      (genhash:register-test-designator 'instance-hash-type
                                        #'(lambda (v)
                                            (logxor (sxhash (car v)) (sxhash (cdr v))))
                                        #'(lambda (v1 v2)
                                            (and (eql (car v1) (car v2))
                                                 (equal (cdr v2) (cdr v2)))))
    (genhash:hash-exists () nil)))

(defun resolvekey (col key)
  "If COL declares KEY as a ref, return its id, otherwise return KEY.
The result is converted according to the applicable store function."
  (funcall (persist-store col)
           (if (and key (persist-ref col))
               (find-instance-id-value key)
               key)))

(defun resolvekey-col (col class entry)
  (resolvekey col (closer-mop:slot-value-using-class class entry col)))

(defgeneric retrieve-id (db entry)
  (:documentation "Returns the autogenerated id for the given ENTRY.
This method is guaranteed to be called in a transaction, immediately after
the data row for ENTRY has been inserted."))

(defmethod retrieve-id (db entry)
  "The default implementation of RETRIEVE-ID simply returns NIL as there is
no database-independent way of implementing this method."
  nil)

(defun save-instance (db entry)
  (let ((class (class-of entry)))
    (unless (typep class 'persisted-db-entry-class)
      (error "Instance metaclass is not ~s" 'persisted-db-entry-class))
    (let* ((columns (find-persisted-cols class '(:write :both)))
           (sql-statement (nconc (list (format nil "insert into ~a (~{~a~^, ~}) values ("
                                               (persisted-db-entry-class-table class)
                                               (mapcar #'(lambda (v) (persist-column v)) columns)))
                                 (loop
                                    for i from 0
                                    for column in columns
                                    unless (zerop i)
                                    collect ","
                                    collect i)
                                 (list ")"))))
      (dhs-db:ensure-transaction (db)
        (dhs-db:with-prepared-statement (statement db sql-statement)
          (dhs-db:execute-prepared statement (mapcar #'(lambda (s)
                                                         (resolvekey-col s class entry))
                                                     columns))
          (let ((id (retrieve-id db entry)))
            (when id
              (setf (closer-mop:slot-value-using-class class entry (find-id-column class)) id))
            entry))))))

(defun find-persisted-updated (entry force-save id-column)
  (remove-if #'(lambda (col)
                 (or (eq col id-column)
                     (and (not force-save)
                          (not (gethash (closer-mop:slot-definition-name col) (db-entry-modification-map entry))))))
             (find-persisted-cols (class-of entry) '(:write :both))))

(defun update-instance (db entry &key force-save)
  (let ((class (class-of entry)))
    (unless (typep class 'persisted-db-entry-class)
      (error "Instance metaclass is not ~s" 'persisted-db-entry-class))
    (let* ((id-column (find-id-column class))
           (columns (find-persisted-updated entry force-save id-column)))
      (when columns
        (let ((sql-statement (nconc (list "update" (persisted-db-entry-class-table class) "set")
                                    (loop
                                       for i from 0
                                       for column in columns
                                       unless (zerop i)
                                       collect ","
                                       append (list (persist-column column) "=" i))
                                    (list "where" (persist-column id-column) "=" (length columns)))))
          (dhs-db:with-prepared-statement (s db sql-statement)
            (dhs-db:execute-prepared s (nconc (mapcar #'(lambda (column)
                                                          (resolvekey-col column class entry))
                                                      columns)
                                              (list (resolvekey-col id-column class entry))))))))))

(defvar *instance-cache* nil)

(defmacro with-active-cache (&body body)
  (let ((func (gensym)))
    `(let ((,func #'(lambda () ,@body)))
       (if *instance-cache*
           (funcall ,func)
           (let ((*instance-cache* (genhash:make-generic-hash-table :test 'instance-hash-type)))
             (funcall ,func))))))

(defun find-instance-from-instance-cache (db foreign-key-type value)
  (if *instance-cache*
      (let* ((key (cons foreign-key-type value))
             (cached-instance (genhash:hashref key *instance-cache*)))
        (if cached-instance
            cached-instance
            (let ((v (find-instance-from-id db foreign-key-type value)))
              (format t "~&cache miss for ~a:~a~%" foreign-key-type value)
              (when v
                (setf (genhash:hashref key *instance-cache*) v)
                v))))
      (find-instance-from-id db foreign-key-type value)))

(defun find-ref (db value column)
  (let ((foreign-key-type (persist-ref column)))
    (if (and value
             foreign-key-type)
        (find-instance-from-instance-cache db foreign-key-type value)
        value)))

(defun load-instance (db element class columns)
  (declare (type dhs-db:connection        db)
           (type simple-vector            element)
           (type persisted-db-entry-class class)
           (type list                     columns))
  (closer-mop:ensure-finalized class)
  (let ((instance (allocate-instance class)))
    (loop
       for i from 0
       for column in columns
       if (find (persist-mode column) '(:read :both))
       do (setf (closer-mop:slot-value-using-class class instance column)
                (funcall (persist-read column) (find-ref db (aref element i) column))))
    ;; This call initialises the modification map, so at this point it has marked all fields as not modified
    (initialize-instance instance)
    instance))

(defun find-instance-list (db type &key where args order-by limit-result)
  (let* ((class (find-class type))
         (columns (find-persisted-cols class '(:read :both)))
         (sql-statement (append (list "select")
                                (loop
                                   for first = t then nil
                                   for s in columns
                                   unless first
                                   collect ","
                                   collect (dhs-db:build-select-col db (persist-data-type s) (persist-column s)))
                                (list "from"
                                      (persisted-db-entry-class-table class))
                                (if where
                                    (list* "where" where)
                                    nil)
                                (if order-by
                                    (list* "order by" order-by)
                                    nil))))
    (dhs-db:with-prepared-statement (statement db sql-statement)
      (with-active-cache
        (let* ((data (dhs-db:execute-prepared-select statement args
                                                     :result-types (mapcar #'persist-data-type columns))))
          (map 'simple-vector #'(lambda (element)
                                  (load-instance db element class columns))
               (if limit-result
                   (subseq data 0 (min (length data) limit-result))
                   data)))))))

(defun find-instance-from-id (db type primary-key)
  (let* ((primary-key-col (find-id-column type)))
    (let ((result (find-instance-list db type
                                      :where (list (persist-column primary-key-col) "=" 0)
                                      :args (list (resolvekey primary-key-col primary-key))
                                      :limit-result 1)))
      (if (zerop (length result))
          nil
          (aref result 0)))))
